perm filename CORD2.F4[CMS,LCS] blob
sn#089288 filedate 1974-03-03 generic text, type T, neo UTF8
00100 COMMON IZ,KZ,F
00200 DIMENSION I(1),IA(1000),KC(6),KC7(6),KCN(6),KCN7(6),
00300 1KD(6),KD7(6),KDN(6),KDN7(6),KG(6),KG7(6),KGN(6),
00400 1KGN7(6),KA(6),KA7(6),KAN(6),KAN7(6),KB(6),KB7(6),
00500 1KBN(6),KBN7(6),KE(6),KE7(6),KEN(6),KEN7(6),KF(6),
00600 1KF7(6),KFN(6),KFN7(6),IX(25),IY(25),JX(25),JY(25)
00700 DATA KC/3,3,2,0,1,0/,KCN/3,3,5,5,4,3/,KC7/0,3,2,3,1,0/
00800 1,KCN7/3,3,5,3,4,6/,KD/0,0,0,2,3,2/,KDN/0,0,0,2,3,1/,
00900 1KD7/0,0,0,2,1,2/,KDN7/0,0,0,2,1,1/,KG/3,2,0,0,0,3/,
01000 1KGN/3,5,5,3,3,3/,KG7/3,2,0,0,0,1/,KGN7/3,5,5,3,6,3/,
01100 1KA/0,0,2,2,2,0/,KA7/0,0,2,1,2,0/,KAN/0,0,2,2,1,0/,
01200 1KAN7/0,0,2,2,1,3/,KB/2,2,4,4,4,2/,KB7/0,2,1,2,0,2/,
01300 1KBN/2,2,4,4,3,2/,KBN7/2,2,4,4,3,5/,KE/0,2,2,1,0,0/,
01400 1KE7/0,2,2,1,3,0/,KEN/0,2,2,0,0,0/,KEN7/0,2,2,0,3,0/,
01500 1KF/1,3,3,2,1,1/,KF7/1,3,1,2,4,1/,KFN/1,3,3,1,1,1/,
01600 1KFN7/1,3,3,1,4,1/,IX/100,150,200,250,300,350,100,
01700 1 100,100,100,100,100,100,100,100,100,100,100,100,
01800 1 100,215,215,215,215,190/,IY/420,420,420,420,420,
01900 1 420,420,350,280,210,140,70,0,-70,-140,-210,-280,
02000 1 -350,-420,425,245,105,-35,-245,-385/
02100 DATA JX/100,150,200,250,300,350,350,350,350,350,
02200 1 350,350,350,350,350,350,350,350,350,350,235,
02300 1 235,235,235,260/,JY/-420,-420,-420,-420,-420,-420,
02400 1 420,350,280,210,140,70,0,-70,-140,-210,-280,-350,
02500 1 -420,425,245,105,-35,-245,-385/
02600 Q=0
02700 2 TYPE 4
02800 4 FORMAT(' STARTING POINTS FOR X,Y,OR SIZE?'/)
02900 ACCEPT 3,IZ,KZ,F
03000 3 FORMAT(2I,F)
03100 IF(F.EQ.0)F=1
03200 GO TO 111
03300 1 IF(Q.EQ.1)GO TO 2
03400 111 TYPE 5
03500 5 FORMAT(' TYPE CHORD NAME'/)
03600 ACCEPT 10,A,B,N
03700 IF(A.EQ.'S')CALL SAVER(I)
03800 IF(A.EQ.'X')Q=1
03900 IF(Q.EQ.0.OR.A.EQ.'X')CALL DPYSET(2,IA,1000)
04000 IF(A.EQ.'X')GO TO 2
04100 10 FORMAT(2A1,I)
04200 DO 12 K=1,25
04300 L1=IX(K)*F+IZ
04400 L2=IY(K)*F+KZ
04500 L3=JX(K)*F+IZ
04600 L4=JY(K)*F+KZ
04700 12 CALL ALINE(L1,L2,L3,L4)
04800 IF(B.EQ.'7')N=7
04900 IF(A.EQ.'C')GO TO 20
05000 IF(A.EQ.'D')GO TO 25
05100 IF(A.EQ.'G')GO TO 30
05200 IF(A.EQ.'A')GO TO 50
05300 IF(A.EQ.'B')GO TO 55
05400 IF(A.EQ.'E')GO TO 60
05500 IF(A.EQ.'F')GO TO 65
05600 GO TO 1
05700 20 IF(B.EQ.'N')GO TO 33
05800 IF(N.EQ.7)CALL X(KC7)
05900 IF(N.EQ.0)CALL X(KC)
06000 GO TO 1
06100 33 IF(N.EQ.7)CALL X(KCN7)
06200 IF(N.EQ.0)CALL X(KCN)
06300 GO TO 1
06400 25 IF(B.EQ.'N')GO TO 44
06500 IF(N.EQ.7)CALL X(KD7)
06600 IF(N.EQ.0)CALL X(KD)
06700 GO TO 1
06800 44 IF(N.EQ.7)CALL X(KDN7)
06900 IF(N.EQ.0)CALL X(KDN)
07000 GO TO 1
07100 30 IF(B.EQ.'N')GO TO 11
07200 IF(N.EQ.7)CALL X(KG7)
07300 IF(N.EQ.0)CALL X(KG)
07400 GO TO 1
07500 11 IF(N.EQ.7)CALL X(KGN7)
07600 IF(N.EQ.0)CALL X(KGN)
07700 GO TO 1
07800 50 IF(B.EQ.'N')GO TO 66
07900 IF(N.EQ.7)CALL X(KA7)
08000 IF(N.EQ.0)CALL X(KA)
08100 GO TO 1
08200 66 IF(N.EQ.7)CALL X(KAN7)
08300 IF(N.EQ.0)CALL X(KAN)
08400 GO TO 1
08500 55 IF(B.EQ.'N')GO TO 67
08600 IF(N.EQ.7)CALL X(KB7)
08700 IF(N.EQ.0)CALL X(KB)
08800 GO TO 1
08900 67 IF(N.EQ.7)CALL X(KBN7)
09000 IF(N.EQ.0)CALL X(KBN)
09100 GO TO 1
09200 60 IF(B.EQ.'N')GO TO 68
09300 IF(N.EQ.7)CALL X(KE7)
09400 IF(N.EQ.0)CALL X(KE)
09500 GO TO 1
09600 68 IF(N.EQ.7)CALL X(KEN7)
09700 IF(N.EQ.0)CALL X(KEN)
09800 GO TO 1
09900 65 IF(B.EQ.'N')GO TO 69
10000 IF(N.EQ.7)CALL X(KF7)
10100 IF(N.EQ.0)CALL X(KF)
10200 GO TO 1
10300 69 IF(N.EQ.7)CALL X(KFN7)
10400 IF(N.EQ.0)CALL X(KFN)
10500 GO TO 1
10600 END
10700
10800 SUBROUTINE X(J)
10900 DIMENSION J(1)
11000 COMMON IZ,KZ,F
11100 DO 1 L=1,6
11200 IF(J(L).EQ.0)GO TO 1
11300 M=(50+50*L)*F+IZ
11400 N=(455-70*J(L))*F+KZ
11500 NX=F*10
11600 CALL ALINE(M-NX,N+NX,M+NX,N-NX)
11700 CALL ALINE(M+NX,N+NX,M-NX,N-NX)
11800 1 CONTINUE
11900 REREAD 2,N
12000 2 FORMAT(A5)
12100 NB=F*6
12200 IF(NB.LT.2)NB=2
12300 IF(NB.GT.7)NB=7
12400 CALL DPYBIG(NB)
12500 KX=-50*F+IZ
12600 KY=200*F+KZ
12700 CALL DPYTXT(KX,KY,N,1)
12800 CALL DPYOUT(2)
12900 RETURN
13000 END
13100
13200 SUBROUTINE SAVER(I)
13300 DIMENSION I(1)
13400 I(1)=I(3)+2
13500 CALL SAVB(I)
13600 C SAVES DPY BUFFER IN FILE 'PLOTZ.DAT'
13700 END